home *** CD-ROM | disk | FTP | other *** search
/ The Best of Windows 95 Shareware / The Best of Windows 95 Shareware (Wayzata Technology)(1996).ISO / pc / txtutils / winedt95 / wedcol.pas < prev    next >
Pascal/Delphi Source File  |  1995-09-28  |  7KB  |  237 lines
  1.  
  2. {************************************************}
  3. {                                                }
  4. {   Turbo Pascal for Windows                     }
  5. {   WINEDT 95 Settings                           }
  6. {   Copyright (c) 1995 by Alex                   }
  7. {                                                }
  8. {************************************************}
  9.  
  10. program WINEDT95_Selections;
  11.  
  12. {$R-}
  13.  
  14. uses Strings, WObjects, WinTypes, WinProcs;
  15.  
  16. type
  17.  
  18.   TRGB = array [0..3] of byte;
  19.  
  20.   PaletteApplication = object(TApplication)
  21.     procedure InitMainWindow; virtual;
  22.   end;
  23.  
  24.   PTestWindow = ^TestWindow;
  25.   TestWindow = object(TWindow)
  26.     TheFont: HFont;
  27.     CW,CH: integer;
  28.     xRGB: byte;
  29.     TextColor: TRGB;
  30.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  31.     destructor Done; virtual;
  32.     procedure Paint(PaintDC: HDC; var PInfo: TPaintStruct); virtual;
  33.     procedure WMLButtonDown(var Msg: TMessage);
  34.       virtual wm_First + wm_LButtonDown;
  35.     procedure WMRButtonDown(var Msg: TMessage);
  36.       virtual wm_First + wm_RButtonDown;
  37.   end;
  38.  
  39. {--------------------------------------------------}
  40. { TestWindow method implementations:               }
  41. {--------------------------------------------------}
  42.  
  43. constructor TestWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  44. var WrDC: HDC;
  45.     ATextMetric: TTextMetric;
  46. begin
  47.   TWindow.Init(AParent, ATitle);
  48.   TheFont:=GetStockObject(OEM_Fixed_Font);
  49.   WrDC:=GetDC(0);
  50.   SelectObject(WrDC, TheFont);
  51.   GetTextMetrics(WrDC, ATextMetric);
  52.   CW:=ATextMetric.tmMaxCharWidth;
  53.   CH:=ATextMetric.tmHeight;
  54.   ReleaseDC(0, WrDC);
  55.   LongInt(TextColor):=0;
  56.   xRGB:=0;
  57. end;
  58.  
  59. destructor TestWindow.Done;
  60. begin
  61.   TWindow.Done;
  62. end;
  63.  
  64. procedure TestWindow.Paint(PaintDC: HDC; var PInfo: TPaintStruct);
  65. var stc: array [0..15] of char;
  66.     xMsg: array [0..255] of char;
  67.     tc,OTC: LongInt;
  68.     otf: HFont;
  69.   procedure StrHEX( s: PChar; c: byte );
  70.     procedure xCon( s: PChar; b: byte );
  71.     begin
  72.       case b of
  73.         0: StrCat(s, '0');
  74.         1: StrCat(s, '1');
  75.         2: StrCat(s, '2');
  76.         3: StrCat(s, '3');
  77.         4: StrCat(s, '4');
  78.         5: StrCat(s, '5');
  79.         6: StrCat(s, '6');
  80.         7: StrCat(s, '7');
  81.         8: StrCat(s, '8');
  82.         9: StrCat(s, '9');
  83.         10: StrCat(s, 'A');
  84.         11: StrCat(s, 'B');
  85.         12: StrCat(s, 'C');
  86.         13: StrCat(s, 'D');
  87.         14: StrCat(s, 'E');
  88.         15: StrCat(s, 'F');
  89.         else StrCat(s, '?');
  90.       end;
  91.     end;
  92.   begin
  93.     xCon(s, c div 16);
  94.     xCon(s, c mod 16);
  95.   end;
  96.   function GetHEX( str: PChar ): LongInt;
  97.   type XColor = record
  98.          dd,cc,bb,aa: byte;
  99.        end;
  100.   var i,j: integer;
  101.       XC: XColor;
  102.       s: array [0..15] of char;
  103.   begin
  104.     StrCopy(s, @Str[1]);
  105.     StrUpper(s);
  106.     j:=0;
  107.     if StrLen(s) >= 8 then begin
  108.       for i:=0 to 7 do begin
  109.         if not (s[i] in ['0'..'9','A'..'F']) then begin
  110.           s[i]:='0';
  111.           Inc(j);
  112.         end;
  113.         if s[i] > '9' then  begin
  114.            s[i]:=chr(ord(s[i]) - ord('A') + ord('9') + 1);
  115.         end;
  116.       end;
  117.       with XC do begin
  118.         i:=0; aa:=16*(ord(s[i])-ord('0'))+ord(s[i+1])-ord('0');
  119.         i:=2; bb:=16*(ord(s[i])-ord('0'))+ord(s[i+1])-ord('0');
  120.         i:=4; cc:=16*(ord(s[i])-ord('0'))+ord(s[i+1])-ord('0');
  121.         i:=6; dd:=16*(ord(s[i])-ord('0'))+ord(s[i+1])-ord('0');
  122.       end;
  123.     end else begin
  124.       LongInt(XC):=0;
  125.     end;
  126.     GetHEX:=LongInt(XC);
  127.   end;
  128.   procedure PaintLine(Index: integer; Col: PChar );
  129.   var BrushColor: LongInt;
  130.       TheOldBK: LongInt;
  131.       TheOldBrush,Brush: HBrush;
  132.       X,Y,DX,DY: LongInt;
  133.   begin
  134.     DX:=100;
  135.     DY:=CH;
  136.     Y:=(CH+2)*(Index div 2) + 99;
  137.     X:=(Index Mod 2)*round(DX*2.5) + 6;
  138.     BrushColor:=GetHEX(Col);
  139.     if BrushColor <> 0 then begin
  140.       Brush:=CreateSolidBrush(BrushColor);
  141.       TheOldBrush:=SelectObject(PaintDC, Brush);
  142.       TheOldBK:=SetBKMode(PaintDC, Transparent);
  143.       PatBlt(PaintDC, X,Y,DX,DY, PatCopy);
  144.     end;
  145.     TextOut(PaintDC, X,Y, Col, StrLen(Col));
  146.     if BrushColor <> 0 then begin
  147.       TheOldBK:=SetBKMode(PaintDC, TheOldBK);
  148.     end;
  149.     x:=x + round(1.1*DX);
  150.     TextOut(PaintDC, X,Y, Col, StrLen(Col));
  151.     PatBlt(PaintDC, X,Y,DX,DY, PatInvert);
  152.     if BrushColor <> 0 then begin
  153.       SelectObject(PaintDC, TheOldBrush);
  154.       DeleteObject(Brush);
  155.     end;
  156.   end;
  157. begin
  158.   otf:=SelectObject(PaintDC, TheFont);
  159.   tc:=0;
  160.   StrCopy(stc,'$00');
  161.   StrHex(@stc[StrLen(stc)], TextColor[2]);
  162.   StrHex(@stc[StrLen(stc)], TextColor[1]);
  163.   StrHex(@stc[StrLen(stc)], TextColor[0]);
  164.   tc:=GetHex(stc);
  165.   StrCopy(xMsg, 'Text Color RGB (');
  166.   if xRGB = 0 then StrCat(xMsg,'R') else
  167.   if xRGB = 1 then StrCat(xMsg,'G') else
  168.   if xRGB = 2 then StrCat(xMsg,'B') else
  169.                    StrCat(xMsg,'*');
  170.   StrCat(xMsg,'): ');
  171.   StrCat(xMsg, stc);
  172.   TextOut(PaintDC, 4,12, xMsg, StrLen(xMsg));
  173.   StrCopy(xMsg, 'Use Left and Right Mouse Buttons');
  174.   TextOut(PaintDC, 25,44, xMsg, StrLen(xMsg));
  175.   StrCopy(xMsg, 'to Change the Color of the Text.');
  176.   TextOut(PaintDC, 25,59, xMsg, StrLen(xMsg));
  177.   if tc <> 0 then OTC:=SetTextColor(PaintDC, tc);
  178.   PaintLine(00, '$00000000');
  179.   PaintLine(01, '$01000000');
  180.   PaintLine(02, '$01000001');
  181.   PaintLine(03, '$01000002');
  182.   PaintLine(04, '$01000003');
  183.   PaintLine(05, '$01000004');
  184.   PaintLine(06, '$01000005');
  185.   PaintLine(07, '$01000006');
  186.   PaintLine(08, '$01000007');
  187.   PaintLine(09, '$01000008');
  188.   PaintLine(10, '$01000009');
  189.   PaintLine(11, '$0100000A');
  190.   PaintLine(12, '$0100000B');
  191.   PaintLine(13, '$0100000C');
  192.   PaintLine(14, '$0100000D');
  193.   PaintLine(15, '$0100000E');
  194.   PaintLine(16, '$0100000F');
  195.   PaintLine(17, '$01000010');
  196.   PaintLine(18, '$01000011');
  197.   PaintLine(19, '$01000012');
  198.   if tc <> 0 then SetTextColor(PaintDC, otc);
  199.   SelectObject(PaintDC, otf);
  200. end;
  201.  
  202. procedure TestWindow.WMLButtonDown(var Msg: TMessage);
  203. begin
  204.   if TextColor[xRGB] =   0 then TextColor[xRGB]:=128 else
  205.   if TextColor[xRGB] = 128 then TextColor[xRGB]:=255 else
  206.                                 TextColor[xRGB]:=0;
  207.   InvalidateRect(HWIndow, nil, true);
  208. end;
  209.  
  210. procedure TestWindow.WMRButtonDown(var Msg: TMessage);
  211. begin
  212.   xRGB:=(xRGB + 1) mod 3;
  213.   InvalidateRect(HWIndow, nil, true);
  214. end;
  215.  
  216. {--------------------------------------------------}
  217. { Application:                                     }
  218. {--------------------------------------------------}
  219.  
  220. procedure PaletteApplication.InitMainWindow;
  221. begin
  222.   MainWindow := New(PTestWindow,Init(nil, 'WINEDT 95:  Text Selections'));
  223. end;
  224.  
  225. {--------------------------------------------------}
  226. { Main program:                                    }
  227. {--------------------------------------------------}
  228.  
  229. var PalApp: PaletteApplication;
  230.  
  231. begin
  232.   PalApp.Init('PaletteApp');
  233.   PalApp.Run;
  234.   PalApp.Done;
  235. end.
  236.  
  237.